HPAVC/HPAVC CD-ROM.iso/pc/PXDTUT4.ZIP/PXDTUT4.PAS

Pascal/Delphi Source File | 1997-06-21 | 38.3 KB | 1,495 lines

program pxdtut4;

uses
 crt;

CONST
 VGA = $a000;

 Num_of_points = 8;
 Num_of_faces = 6;

 Xofs = 160;
 yofs = 100;
 Zeye = -200;

 YTopClip = 0;
 YBotClip = 200;


TYPE
  PointT = record
             x,y,z : integer;
          end;                                {6 bytes pr point}

  RealPointT = Record
                x,y,z : real;                {18 bytes pr. point}
              end;


  ScrPointT = record
               x,y : integer;                 {4 bytes pr point}
             end;

  FaceT = record
           P1,P2,P3,P4 : integer;             {9 bytes pr face}
           color  : byte;
         end;


  SegmentT = Array[0..65534] of byte;
  Virseg = ^SegmentT;


  PointRecord    = Array[1..Num_of_points] of PointT;    {points *  6 bytes}
  FaceRecord     = Array[1..Num_of_faces] of FaceT;      {faces  *  9 bytes}
  ScrPointRecord = Array[1..Num_of_points] of ScrPointT; {points *  4 bytes}
  CenterRecord   = Array[1..Num_of_faces] of integer;    {faces  *  2 bytes}
  NormalRecordT  = Array[1..Num_of_faces] of PointT;     {faces  *  6 bytes}


  Virtualscreen = Array[1..64000] of byte;
  Virscr = ^VirtualScreen;

VAR
 lookup     : Array [0..360,1..2] of integer; {Our sin and cos lookup table}
 Baseobj    : PointRecord;       {original 3d-object}
 Faces      : FaceRecord;        {data for how faces is defined}
 Points     : PointRecord;       {rotated 3d-object}
 Translated : ScrPointRecord;    {the 2d-screenpoints for drawing}
 Centers    : CenterRecord;      {Z-val of centers for depth sorting}
 OrderTable : Array[1..Num_of_faces] of integer; {how to handle faces correct}
 Normals    : NormalRecordT;     {original normalized normal vectors}
 RotNormals : NormalRecordT;     {Rotated normal vectors}
 LightVect  : RealPointT;        {where is the lightsource ?? }


 Xrot,Yrot, Zrot : integer;
 scr2 : virscr;
 vaddr : word;

 TexSegment : Virseg;
 texture : word;



PROCEDURE WaitRetrace;
Assembler;
label l1,l2;

asm
 mov dx,3DAh
l1:
  in al,dx
  and al,08h
  jnz l1
l2:
  in al,dx
  and al,08h
  jz l2
END;


Procedure FlipScreen(source, dest : word);
Assembler; {386 only}
asm
  mov     dx, ds
  mov     ax, [dest]
  mov     es, ax
  mov     ax, [source]
  mov     ds, ax
  xor     si, si
  xor     di, di
  mov     cx, 16000
  db      $66
  rep     movsw
  mov     ds,dx    {mov's are faster than push / pops }
end;

Procedure Clear (Col : Byte;where:word);
Assembler;
     asm
        mov     cx, 32000;
        mov     ax,where
        mov     es,ax
        xor     di,di
        mov     al,[col]
        mov     ah,al
        rep     stosw
      END;

Function rad (theta : real) : real;
BEGIN
  rad := theta * pi / 180
END;

Procedure Greyscale;
var
 taeller : integer;
begin
 for taeller := 0 to 63 do
   begin   {63 shades from black to white}
    port[$3C8] := taeller;
    port[$3C9] := taeller;
    port[$3C9] := taeller;
    port[$3C9] := taeller;
   end;
end;

Procedure PurplePal;
var
 taeller : integer;
begin
 for taeller := 0 to 63 do
   begin   {63 shades from black to purple}
    port[$3C8] := taeller;
    port[$3C9] := taeller;
    port[$3C9] := 0;
    port[$3C9] := taeller;
   end;
end;

Procedure FakePhongPal;
var
 taeller : integer;
begin
 for taeller := 1 to 63 do
   begin   {63 shades from black to purple}
    port[$3C8] := taeller;
    port[$3C9] := taeller;
    port[$3C9] := 10+Round(taeller/1.4);
    port[$3C9] := 20+Round(taeller/1.6);
   end;
end;


PROCEDURE SetUpVirtual(VAR screenname:virscr;VAR add : word);
BEGIN
  GetMem (Screenname,64000);
  add := seg (Screenname^);
  clear(0,add);
END;

PROCEDURE ShutDown(Screenname:virscr);
BEGIN
  FreeMem (Screenname,64000);
END;

PROCEDURE SetUpSegment(VAR segname:virseg;VAR add : word);
BEGIN
  GetMem (Segname,65534);
  add := seg (Segname^);
END;

PROCEDURE CalcFakePhongMap(where : word);
var
 I,J : byte;
begin
For I:=0 To 255 Do For J:=0 To 255 Do
  Begin
     Mem[where:(256*I)+J]:=
         Round(Sqr(Sqr(Sin(I/81.487)))*Sqr(Sqr(Sin(J/81.487)))*62)+1;
   {
     Mem[$A000:320*Round(I/1.25)+J]:=Mem[where:(256*I)+J];
    }

  end;
end;

PROCEDURE PointNormal(nr : integer; var result : RealPointT);
var
 taeller : integer;
 AntalHits    : byte;
 SumX,SumY,SumZ     : integer;
 Hits    : Array[1..25] of integer;
 length : real;
begin
AntalHits := 0;
SumX := 0;  SumY := 0; SumZ := 0;
 For taeller := 1 to Num_Of_Faces do
     if (faces[taeller].P1 = nr) or (faces[taeller].P2 = nr) or
        (faces[taeller].P3 = nr) or (faces[taeller].P4 = nr) then
          begin
            inc(AntalHits);
            Hits[AntalHits] := taeller;
          end; {in which faces does the point appear}

 For taeller := 1 to AntalHits do
   begin
      SumX := SumX + RotNormals[hits[taeller]].X;
      SumY := SumY + RotNormals[hits[taeller]].Y;
      SumZ := SumZ + RotNormals[hits[taeller]].Z;
   end;
result.X := (SumX div AntalHits) / 256;
result.Y := (SumY div AntalHits) / 256;
result.Z := (SumZ div AntalHits) / 256;

length := sqrt(Result.X*Result.X + Result.Y * Result.Y + Result.Z*Result.Z);

Result.X := Result.X / length;
Result.Y := Result.Y / length;
Result.Z := Result.Z / length;

{result is the average values of the normals to the faces in which the point
 appear}
end;

PROCEDURE FixedPointNormal(nr : integer; var result : PointT);
var
 taeller : integer;
 AntalHits    : byte;
 SumX,SumY,SumZ     : integer;
 Hits    : Array[1..25] of integer;
 tempx,tempy,tempz : real;
 length : real;
begin
AntalHits := 0;
SumX := 0;  SumY := 0; SumZ := 0;
 For taeller := 1 to Num_Of_Faces do
     if (faces[taeller].P1 = nr) or (faces[taeller].P2 = nr) or
        (faces[taeller].P3 = nr) or (faces[taeller].P4 = nr) then
          begin
            inc(AntalHits);
            Hits[AntalHits] := taeller;
          end; {in which faces does the point appear}

 For taeller := 1 to AntalHits do
   begin
      SumX := SumX + RotNormals[hits[taeller]].X;
      SumY := SumY + RotNormals[hits[taeller]].Y;
      SumZ := SumZ + RotNormals[hits[taeller]].Z;
   end;

tempX := (SumX div AntalHits) / 256;
tempY := (SumY div AntalHits) / 256;
tempZ := (SumZ div AntalHits) / 256;

length := sqrt(tempX*tempX + TempY * TempY + TempZ*TempZ);

Result.X := Round((TempX / length)*256);
Result.Y := Round((TempY / length)*256);
Result.Z := Round((TempZ / length)*256);

{result is the average values of the normals to the faces in which the point
 appear}
end;

Procedure Calc_Cos_sin;
var
 loop1 : integer;
begin
 For loop1:=0 to 360 do
   BEGIN
    lookup [loop1,1]:=round(sin (rad (loop1))*16384);
    lookup [loop1,2]:=round(cos (rad (loop1))*16384);
   END;
end;

FUNCTION Xconv(X,Z : integer):integer;
BEGIN
 Xconv:=Xofs+Round(X*(Zeye/(Zeye-Z)));
END;

FUNCTION Yconv(Y,Z : integer):integer;
BEGIN
 Yconv:=Yofs+Round(Y*(Zeye/(Zeye-Z)));
END;




Procedure RotatePoint (Xrot,Yrot,Zrot,Xin,Yin,Zin:Integer;var Xout,Yout,Zout : integer);
VAR
  a,b,c:integer;
BEGIN
      b:=lookup[Yrot,2];
      c:=Xin;
      asm
        mov   ax,b
        imul  c
        sal   ax,1
        rcl   dx,1
        sal   ax,1
        rcl   dx,1
        mov   a,dx
      end;
      b:=lookup[Yrot,1];
      c:=Zin;
      asm
        mov   ax,b
        imul  c
        sal   ax,1
        rcl   dx,1
        sal   ax,1
        rcl   dx,1
        add   a,dx
      end;
      Xout:=a;
      Yout:=Yin;
      b:=-lookup[Yrot,1];
      c:=Xin;
      asm
        mov   ax,b
        imul  c
        sal   ax,1
        rcl   dx,1
        sal   ax,1
        rcl   dx,1
        mov   a,dx
      end;
      b:=lookup[Yrot,2];
      c:=Zin;
      asm
        mov   ax,b
        imul  c
        sal   ax,1
        rcl   dx,1
        sal   ax,1
        rcl   dx,1
        add   a,dx
      end;
      Zout:=a;

  if (Xrot<>0) THEN
     BEGIN
        b:=lookup[Xrot,2];
        c:=Yout;
        asm
          mov   ax,b
          imul  c
          sal   ax,1
          rcl   dx,1
          sal   ax,1
          rcl   dx,1
          mov   a,dx
        end;
        b:=lookup[Xrot,1];
        c:=Zout;
        asm
          mov   ax,b
          imul  c
          sal   ax,1
          rcl   dx,1
          sal   ax,1
          rcl   dx,1
          sub   a,dx
        end;
        b:=lookup[Xrot,1];
        c:=Yout;
        Yout:=a;
        asm
          mov   ax,b
          imul  c
          sal   ax,1
          rcl   dx,1
          sal   ax,1
          rcl   dx,1
          mov   a,dx
        end;
        b:=lookup[Xrot,2];
        c:=Zout;
        asm
          mov   ax,b
          imul  c
          sal   ax,1
          rcl   dx,1
          sal   ax,1
          rcl   dx,1
          add   a,dx
        end;
        Zout:=a;
     END; {if Xrot <> 0 }


 if (Zrot<>0) THEN
     BEGIN
        b:=lookup[Zrot,2];
        c:=Xout;
        asm
          mov   ax,b
          imul  c
          sal   ax,1
          rcl   dx,1
          sal   ax,1
          rcl   dx,1
          mov   a,dx
        end;
        b:=lookup[Zrot,1];
        c:=Yout;
        asm
          mov   ax,b
          imul  c
          sal   ax,1
          rcl   dx,1
          sal   ax,1
          rcl   dx,1
          sub   a,dx
        end;
        b:=lookup[Zrot,1];
        c:=Xout;
        Xout:=a;
        asm
          mov   ax,b
          imul  c
          sal   ax,1
          rcl   dx,1
          sal   ax,1
          rcl   dx,1
          mov   a,dx
        end;
        b:=lookup[Zrot,2];
        c:=Yout;
        asm
          mov   ax,b
          imul  c
          sal   ax,1
          rcl   dx,1
          sal   ax,1
          rcl   dx,1
          add   a,dx
        end;
        Yout:=a;
     END; {if Zrot <> 0 }
END; {This one I grapped from some Asphyxia tuturial.... thnx Denthor }


Procedure Init_Object;
var
 taeller : integer;
 Ax,Ay,Az,Bx,By,Bz : integer;  {vectorer til beregning af normal}
 Nx,Ny,Nz          : integer;  {normal-vectoren}
 laengde,powers : real;
begin
  baseobj[1].X := -50;
  baseobj[1].Y := -50;
  baseobj[1].Z := -50;

  baseobj[2].X :=  50;
  baseobj[2].Y := -50;
  baseobj[2].Z := -50;

  baseobj[3].X := -50;
  baseobj[3].Y :=  50;
  baseobj[3].Z := -50;

  baseobj[4].X :=  50;
  baseobj[4].Y :=  50;
  baseobj[4].Z := -50;

  baseobj[5].X := -50;
  baseobj[5].Y := -50;
  baseobj[5].Z :=  50;

  baseobj[6].X :=  50;
  baseobj[6].Y := -50;
  baseobj[6].Z :=  50;

  baseobj[7].X := -50;
  baseobj[7].Y :=  50;
  baseobj[7].Z :=  50;

  baseobj[8].X :=  50;
  baseobj[8].Y :=  50;
  baseobj[8].Z :=  50;

  faces[1].P1 :=   1;
  faces[1].P2 :=   2;
  faces[1].P3 :=   4;
  faces[1].P4 :=   3;

  faces[2].P1 :=   2;
  faces[2].P2 :=   6;
  faces[2].P3 :=   8;
  faces[2].P4 :=   4;

  faces[3].P1 :=   5;
  faces[3].P2 :=   7;
  faces[3].P3 :=   8;
  faces[3].P4 :=   6;

  faces[4].P1 :=   1;
  faces[4].P2 :=   3;
  faces[4].P3 :=   7;
  faces[4].P4 :=   5;

  faces[5].P1 :=   1;
  faces[5].P2 :=   5;
  faces[5].P3 :=   6;
  faces[5].P4 :=   2;

  faces[6].P1 :=   3;
  faces[6].P2 :=   4;
  faces[6].P3 :=   8;
  faces[6].P4 :=   7;

  for taeller := 1 to Num_of_faces do
     faces[taeller].color :=  0 + taeller * 2;

  for taeller := 1 to Num_of_faces do
    begin
      Ax := (baseobj[faces[taeller].P2].X - baseobj[faces[taeller].P1].X) div 10;
      Ay := (baseobj[faces[taeller].P2].Y - baseobj[faces[taeller].P1].Y) div 10;
      Az := (baseobj[faces[taeller].P2].Z - baseobj[faces[taeller].P1].Z) div 10;

      Bx := (baseobj[faces[taeller].P4].X - baseobj[faces[taeller].P1].X) div 10;
      By := (baseobj[faces[taeller].P4].Y - baseobj[faces[taeller].P1].Y) div 10;
      Bz := (baseobj[faces[taeller].P4].Z - baseobj[faces[taeller].P1].Z) div 10;

      Nx := (Ay*Bz) - (Az*By);
      Ny := (Az*Bx) - (Ax*Bz);
      Nz := (Ax*By) - (Ay*Bx);

      laengde := Sqrt(Nx*Nx + Ny*Ny + Nz*Nz);


      normals[taeller].X := Round((Nx/laengde) * 256);
      normals[taeller].Y := Round((Ny/laengde) * 256);
      normals[taeller].Z := round((Nz/laengde) * 256);
     end;
     RotNormals := Normals;
end;



Procedure HorLine(Xbegin, Xend,Ypos : integer;color : byte;where : word);
Assembler;
asm
 mov cx,[Xend]
 inc cx
 sub cx,[Xbegin]   {cx = length of line - used for counter }
                   {note, I assume that Xbegin < Xend - the poly routine}
                   {will take care of that...}
 mov ax,[ypos]
 shl ax,8
 mov di,ax
 shr ax,2
 add di,ax
 add di,[Xbegin]   {di = Ypos * 320 + Xbegin - offset for our line}
 mov es,[where]    {where to draw..}

 mov al,[color]
 rep stosb         {I draw byte by byte - slower than drawing a word at a}
                   {time but it is because of the changes we are going to}
                   {make to this routine when glenzing/gouraud/texturemapping}
end;


PROCEDURE GouraudHorline(xbeg,xend,y:integer; c1,c2:byte;where : word);
var coloradd : integer;
begin
 if (Xend-Xbeg) <> 0 then
 coloradd := ((c2-c1) shl 8) div (Xend-Xbeg)
 else coloradd := 0;
asm
  mov bx,[xbeg]
  mov cx,[Xend]

  inc cx
  sub cx,bx             { length of line in cx }
  mov es,Where         { segment to draw in }
  mov ax,[y]            { heigth of line }
  shl ax,6
  mov di,ax
  shl ax,2
  add di,ax             { y*320 in di (offset) }
  add di,bx             { add x-begin }

  xor ax,ax
  mov al,[C1]
  shl ax,8              {colorstart fixed-p}

 @again:
  mov es:[di],ah        {ah = real vaerdi af fixed-p color}
  inc di
  dec cx
  add ax,[coloradd]
  cmp cx,0
  jne @again
 @out:
end;
end;


PROCEDURE TextureMapHorline(xbeg,xend,y,u1,v1,u2,v2:integer;source,dest : word);
var
  DeltaX : integer;
  DeltaY : integer;

begin
  If (Xend-Xbeg) <> 0 then
   begin
     DeltaX := ((u2-u1) shl 7) div (Xend-Xbeg);
     DeltaY := ((v2-v1) shl 7) div (Xend-Xbeg);  { 9.7 fixed-p}
     DeltaX := DeltaX + DeltaX;
     DeltaY := DeltaY + DeltaY;                  {now 8.8 fixed-p :)  }
   end
    else
   begin
    DeltaX := 0;
    DeltaY := 0;
   end;
asm
  push ds
  mov ax, [source]
  mov ds,ax

  mov bx,[xbeg]
  mov cx,[Xend]
  inc cx
  sub cx,bx            {cx =  length of line}

  mov es,dest
  mov ax,[y]
  shl ax,6
  mov di,ax
  shl ax,2
  add di,ax
  add di,bx           {es:[di] start of line}

  mov ah,byte[v1]   {8.8 fixed-p value of YTexturePos - for easy ofs calc}
  mov al,byte[u1]
  mov si,ax         {si = starting offset in texture }
  mov dh,al         {8.8 fixed-p value of XTexturePos - for easy ofs calc}

@again:
  movsb               {draw byte}
  add ax,[DeltaY]     {advance in texturemap}
  add dx,[DeltaX]     {advance in texturemap}

  mov bh,ah           {bh = Ypos * 256 }
  mov bl,dh           {bl = Xpos_fixed / 256  = Xpos_real}
  mov si,bx           {BX = Ypos_real * 256 + Xpos_real = offset}

  dec cx
  cmp cx,0
  jne @again          {are we finished ??  }

  pop ds
end;
end;



Procedure Polygon(X1,Y1,X2,Y2,X3,Y3,X4,Y4 : integer;color : byte; where : word);
var
 counter : integer;
 Ymin, Ymax : integer;
 polygon : Array[0..199,1..2] of integer;

Procedure ScanPolySide(X1,Y1,X2,Y2 : integer);
var
 DeltaX : integer;
 temp : integer;
 Xposfixed,Xpos : integer;
 counter : integer;
begin
  if Y2=Y1 then exit;          {exit if side is a horizontal line }
  if (Y2<Y1) then              {make sure Y1 is top point}
               begin
                 temp := Y1;
                 Y1 := Y2;
                 Y2 := temp;

                 temp := X1;
                 X1 := X2;
                 X2 := temp;   {switch the points if Y1 is not top..}
               end;

  DeltaX := ((X2-X1) shl 7) div (Y2-Y1); {DeltaX in 9.7 fixed point math}
  Xposfixed := X1 shl 7; {Xpos in 9.7 fixed point math }
    for counter := Y1 to Y2 do
         begin
           Xpos := XposFixed shr 7;
           if (Xpos < polygon[counter,1]) then polygon[counter,1] := Xpos;
           if (Xpos > polygon[counter,2]) then polygon[counter,2] := Xpos;
           Xposfixed := XposFixed + DeltaX;
         end;
end;


begin
 Ymin := Y1;
 Ymax := Y1;
 if (Y2 < Ymin) then Ymin := Y2;
 if (Y2 > Ymax) then Ymax := Y2;
 if (Y3 < Ymin) then Ymin := Y3;
 if (Y3 > Ymax) then Ymax := Y3;
 if (Y4 < Ymin) then Ymin := Y4;
 if (Y4 > Ymax) then Ymax := Y4;  {what is Ymin and Ymax in this polygon ?}

 if (Ymin < 0) then Ymin := 0;
 if (Ymax > 199) then Ymax := 199;

 for counter := 0 to 199 do
   begin
     polygon[counter,1] := 32000;
     polygon[counter,2] := -32000;
   end;

 {we have to initialize our variable 'polygon' to some extreme values}

 ScanPolySide(X1,Y1,X2,Y2);
 ScanPolySide(X2,Y2,X3,Y3);
 ScanPolySide(X3,Y3,X4,Y4);
 ScanPolySide(X4,Y4,X1,Y1); {all four sides scanned}

 for counter := Ymin to Ymax do
    Horline(polygon[counter,1],polygon[counter,2],counter,color,where);
end;




Procedure GouraudPolygon(x1,y1,x2,y2,x3,y3,x4,y4:integer;C1,C2,C3,C4:byte;where:word);
  { This draw a polygon with 4 points at x1,y1 , x2,y2 , x3,y3 , x4,y4
    in color col }
var miny,maxy:integer;
    loop1:integer;
    poly : Array[0..199,1..2] of integer;
    Colors : Array[0..199,1..2] of byte;

Procedure doside (x1,y1,x2,y2:integer;c1,c2 : byte);
  { This scans the side of a polygon and updates the poly variable }
  {updates the colors variable for gouraud shading}
VAR temp:integer;
    xfixed,xinc,x:integer;
    loop1:integer;
    dcol : integer;
    color : integer;
BEGIN
  if y1=y2 then exit;
  if y2<y1 then
   BEGIN
     temp:=y2;
     y2:=y1;
     y1:=temp;
     temp:=x2;
     x2:=x1;
     x1:=temp;
     temp := c2;
     c2 := c1;
     c1 := temp;
   END;          {make sure y1 is top and y2 bottom}
  dcol := ((c2-c1) shl 8) div (Y2-Y1);    {delta color pr. y-line}
  color := c1 shl 8;      {startcolor i fixed-p}

  xinc:=((x2-x1) shl 7) div (y2-y1); {xinc in fixed point}
  xfixed:=x1 shl 7;
  for loop1:=y1 to y2 do BEGIN
    if (loop1>(ytopclip)) and (loop1<(ybotclip)) then
      BEGIN
        x := xfixed shr 7;
        if (x<poly[loop1,1]) then
         begin
           poly[loop1,1]:=x;
           colors[loop1,1] := color shr 8;
         end;
        if (x>poly[loop1,2]) then
         begin
           poly[loop1,2]:=x;
           colors[loop1,2] := color shr 8;
         end;
      END;
    xfixed:=xfixed+xinc;
    color := color + dcol;
  END;
END;

begin
 for loop1 := 0 to 199 do
  begin
    poly[loop1,1] :=32766;
    poly[loop1,2] :=-32767;
  end;                      {set minx og maxx to extremes}

  miny:=y1;
  maxy:=y1;
  if y2<miny then miny:=y2;
  if y3<miny then miny:=y3;
  if y4<miny then miny:=y4;

  if y2>maxy then maxy:=y2;
  if y3>maxy then maxy:=y3;
  if y4>maxy then maxy:=y4;  {MinY and MaxY for drawing later on}

  if miny<ytopclip then miny:=ytopclip;
  if maxy>ybotclip then maxy:=ybotclip;  {clipping}

  if (miny>199) or (maxy<0) then exit;  {is poly completely of screen?}

  Doside (x1,y1,x2,y2,c1,c2);

  Doside (x2,y2,x3,y3,c2,c3);
  Doside (x3,y3,x4,y4,c3,c4);
  Doside (x4,y4,x1,y1,c4,c1);  {scan each side and update poly-variable}

  for loop1:= miny to maxy do

    GouraudHorline (poly[loop1,1],poly[loop1,2],loop1,
                    colors[loop1,1],colors[loop1,2],where);
end;

Procedure TextureMapPolygon(x1,y1,x2,y2,x3,y3,x4,y4:integer;
                            u1,v1,u2,v2,u3,v3,u4,v4: byte;source,dest:word);
var miny,maxy:integer;
    loop1:integer;
    poly : Array[0..199,1..2] of integer;
    Texture : Array[0..199,1..4] of byte;

Procedure doside (x1,y1,x2,y2:integer;u1,v1,u2,v2 : byte);
  { This scans the side of a polygon and updates the poly variable }
  {updates the textures variable for texturemapping}
VAR temp:integer;
    xfixed,xinc,x:integer;
    loop1:integer;
    dcol : integer;
    deltaX, DeltaY : integer;
    Xpos, Ypos : word;
    color : integer;
BEGIN
  if y1=y2 then exit;
  if y2<y1 then
   BEGIN
     temp:=y2;
     y2:=y1;
     y1:=temp;
     temp:=x2;
     x2:=x1;
     x1:=temp;
     temp := u2;
     u2 := u1;
     u1 := temp;
     temp := v2;
     v2 := v1;
     v1 := temp;
   END;          {make sure y1 is top and y2 bottom}

  DeltaX := ((u2-u1) shl 7) div (Y2-Y1);  {steps through texture in 9.7}
  DeltaY := ((v2-v1) shl 7) div (Y2-Y1);  {fixed-point}
  Xpos := u1 shl 7;
  Ypos := v1 shl 7;     {starting texture positions}

  xinc:=((x2-x1) shl 7) div (y2-y1); {xinc in fixed point}
  xfixed:=x1 shl 7;
  for loop1:=y1 to y2 do BEGIN
    if (loop1>(ytopclip)) and (loop1<(ybotclip)) then
      BEGIN
        x := xfixed shr 7;
        if (x<poly[loop1,1]) then
         begin
           poly[loop1,1]:=x;
           texture[loop1,1] := Xpos shr 7;
           texture[loop1,2] := Ypos shr 7;
         end;
        if (x>poly[loop1,2]) then
         begin
           poly[loop1,2]:=x;
           texture[loop1,3] := Xpos shr 7;
           texture[loop1,4] := Ypos shr 7;
         end;
      END;
    xfixed:=xfixed+xinc;
    Xpos := Xpos + DeltaX;
    Ypos := Ypos + DeltaY;
  END;
END;

begin
 for loop1 := 0 to 199 do
  begin
    poly[loop1,1] :=32766;
    poly[loop1,2] :=-32767;
  end;                      {set minx og maxx to extremes}

  miny:=y1;
  maxy:=y1;
  if y2<miny then miny:=y2;
  if y3<miny then miny:=y3;
  if y4<miny then miny:=y4;

  if y2>maxy then maxy:=y2;
  if y3>maxy then maxy:=y3;
  if y4>maxy then maxy:=y4;  {MinY and MaxY for drawing later on}

  if miny<ytopclip then miny:=ytopclip;
  if maxy>ybotclip then maxy:=ybotclip;  {clipping}

  if (miny>199) or (maxy<0) then exit;  {is poly completely of screen?}

  Doside (x1,y1,x2,y2,u1,v1,u2,v2);

  Doside (x2,y2,x3,y3,u2,v2,u3,v3);
  Doside (x3,y3,x4,y4,u3,v3,u4,v4);
  Doside (x4,y4,x1,y1,u4,v4,u1,v1); {scan each side and update poly-variable}

  for loop1:= miny to maxy do

    TextureMapHorline (poly[loop1,1],poly[loop1,2],loop1,
                    texture[loop1,1],texture[loop1,2],
                    texture[loop1,3],texture[loop1,4],source,dest);

end;




Procedure Rotateobj(x,y,z : integer);
{Rotates all points and calculates center Z-val for sorting}
var
 taeller : integer;
begin
 for taeller := 1 to num_of_points do
  RotatePoint(x,y,z,baseobj[taeller].x,baseobj[taeller].y,baseobj[taeller].z,
              points[taeller].x,points[taeller].y,points[taeller].z);


 for taeller := 1 to num_of_faces do
    centers[taeller] :=
     (points[faces[taeller].P1].Z + points[faces[taeller].P2].Z +
      points[faces[taeller].P3].Z + points[faces[taeller].P4].Z);
    {average Z-val for face. NOTE : SHOULD divide by 4.. but that is really}
    {not nessesary. This way all the values will be the correct val times 4}
    {As ALL values is 4 times too big they will still sort correct :)      }
end;


Procedure RotateNormals(x,y,z : integer);
{Roterer alle normals}
var
 taeller : integer;
begin
 for taeller := 1 to num_of_faces do
  RotatePoint(x,y,z,normals[taeller].x,normals[taeller].y,normals[taeller].z,
              RotNormals[taeller].x,RotNormals[taeller].y,RotNormals[taeller].z);


end;



Procedure Sort_faces;
{Just a simple bubble-sort - not to fast but what the heck :) }
{Faces with the HIGHEST Z-val is placed first in Order[] }
VAR
  counter : integer;
  position : integer;
  tempval : integer;
BEGIN
  for counter:=1 to Num_of_faces do BEGIN
    OrderTable[counter]:=counter;
  END;
  {we resets the ordertable so that it matches the unsorted 'centers' variable}
  position := 1;

  repeat
    if (centers[position] < centers[position+1]) then
        BEGIN   {switch values in centers and ordertable}
          tempval := Centers[position+1];
          Centers[position+1] := centers[position];
          centers[position] := tempval;

          tempval := OrderTable[position+1];
          OrderTable[position+1] := OrderTable[position];
          OrderTable[position] := tempval;

          position:=1;   {start loop over}
        END;
      inc(position);
  until (position = Num_of_faces);  {all way through without changes}
END;


Procedure Project_points;
var
 taeller : integer;
begin
 for taeller := 1 to Num_of_points do
    begin
      translated[taeller].X := Xconv(points[taeller].X,points[taeller].Z);
      translated[taeller].Y := Yconv(points[taeller].Y,points[taeller].Z);
     end;
end;


Procedure BadFlatShade(where : word; minZ, maxZ, Num_of_shades : integer);
{********************************************************************}
{**  MinZ, MaxZ : What is the minimum and maximum Z-values of the  **}
{**               faces that is to be drawn ? You COULD set theese **}
{**               values so that minZ is the minimum Z-val of the  **}
{**               entire object and MaxZ the maximum value. However**}
{**               consider the fact that half of the objects faces **}
{**               is removed by hidden face removal. So, if you    **}
{**               want to have bigger diference on the shown faces **}
{**               just set minZ to minimum object Z-value and MaxZ **}
{**               to the Z-value of the CENTER of the object.      **}
{**               Experiment!!                                     **}
{** Num_of_shades : shades used = color 0 to Num_of_shades         **}
{********************************************************************}

var
 taeller : integer;
 X1,Y1,X2,Y2,X3,Y3,X4,Y4 : integer;
 color : byte;
 polynr : integer;
 normal,span : integer;
 shade : real;
begin
 for taeller := 1 to Num_of_faces do
   begin
     polynr := orderTable[taeller];
     X1 := translated[faces[polynr].P1].X;
     Y1 := translated[faces[polynr].P1].Y;
     X2 := translated[faces[polynr].P2].X;
     Y2 := translated[faces[polynr].P2].Y;
     X3 := translated[faces[polynr].P3].X;
     Y3 := translated[faces[polynr].P3].Y;
     X4 := translated[faces[polynr].P4].X;
     Y4 := translated[faces[polynr].P4].Y;

     {***************** Z-shading *****************}

     span := ABS (minZ-maxZ);   {Z span of object}
     shade := (centers[taeller] div 4 + ABS(minZ)) / span;

     color := Num_of_shades - round(Num_of_shades*shade);

     {*******************************************************}
     {******* HIDDEN FACE REMOVAL - YES, THAT EASY ;) *******}
     {*******************************************************}
     {Z-Comp of normal to 2d-polygon}
     normal := (Y1-Y3)*(X2-X1) - (X1-X3)*(Y2-Y1);
       if (normal < 0) then {pointing towards us}
         Polygon(X1,Y1,X2,Y2,X3,Y3,X4,Y4,color,where);
     {*******************************************************}
     {*******************************************************}
     {*******************************************************}
   end;
end;


Procedure NiceFlatShade(where : word; Num_of_shades : integer);
var
 taeller : integer;
 X1,Y1,X2,Y2,X3,Y3,X4,Y4 : integer;
 color : byte;
 polynr : integer;
 normal : integer;
 shade : real;
 Nx,Ny,Nz : real;
 dot : real;

begin
 for taeller := 1 to Num_of_faces do
   begin
     polynr := orderTable[taeller];
     X1 := translated[faces[polynr].P1].X;
     Y1 := translated[faces[polynr].P1].Y;
     X2 := translated[faces[polynr].P2].X;
     Y2 := translated[faces[polynr].P2].Y;
     X3 := translated[faces[polynr].P3].X;
     Y3 := translated[faces[polynr].P3].Y;
     X4 := translated[faces[polynr].P4].X;
     Y4 := translated[faces[polynr].P4].Y;


     {*******************************************************}
     {******* HIDDEN FACE REMOVAL - YES, THAT EASY ;) *******}
     {*******************************************************}
     {Z-Comp of normal to 2d-polygon}
     normal := (Y1-Y3)*(X2-X1) - (X1-X3)*(Y2-Y1);


       if (Normal < 0) then {pointing towards us}
         begin
           {************************************************************}
           {**   LAMBERTS FLATSHADIG ACCORDING TO MOVING LIGHTSOURCE  **}
           {************************************************************}

           Nx := RotNormals[polynr].X / 256;
           Ny := RotNormals[polynr].Y / 256;
           Nz := RotNormals[polynr].Z / 256;

          dot := (Nx*Lightvect.X) + (Ny*Lightvect.Y) + (Nz*Lightvect.Z);
          if (dot > 1) or (dot < 0) then dot := 0;
          color := Round(dot * Num_of_shades);
          Polygon(X1,Y1,X2,Y2,X3,Y3,X4,Y4,color,where);
         end;
     {*******************************************************}
     {*******************************************************}
     {*******************************************************}
   end;
end;


Procedure GouraudShade(where : word; Num_of_shades : integer);
var
 taeller : integer;
 X1,Y1,X2,Y2,X3,Y3,X4,Y4 : integer;
 C1,C2,C3,C4 : byte;
 polynr : integer;
 normal : integer;
 shade : real;
 {Nx,Ny,Nz : real;}
 norm : RealPointT;
 dot : real;

begin
 for taeller := 1 to Num_of_faces do
   begin
     polynr := orderTable[taeller];
     X1 := translated[faces[polynr].P1].X;
     Y1 := translated[faces[polynr].P1].Y;
     X2 := translated[faces[polynr].P2].X;
     Y2 := translated[faces[polynr].P2].Y;
     X3 := translated[faces[polynr].P3].X;
     Y3 := translated[faces[polynr].P3].Y;
     X4 := translated[faces[polynr].P4].X;
     Y4 := translated[faces[polynr].P4].Y;


     {*******************************************************}
     {******* HIDDEN FACE REMOVAL - YES, THAT EASY ;) *******}
     {*******************************************************}
     {Z-Comp of normal to 2d-polygon}
     normal := (Y1-Y3)*(X2-X1) - (X1-X3)*(Y2-Y1);
       if (normal < 0) then {pointing towards us}
         begin
           {************************************************************}
           {**   GOURAUD SHADING ACCORDING TO MOVING LIGHTSOURCE      **}
           {************************************************************}

          PointNormal(faces[polynr].P1,norm);
          dot := (norm.x*Lightvect.X) + (Norm.y*Lightvect.Y) + (Norm.z*Lightvect.Z);
          if (dot > 1) then dot := 1;
          if (dot < 0) then dot := 0;
          C1 := Round(dot * Num_of_shades);

          PointNormal(faces[polynr].P2,norm);
          dot := (norm.x*Lightvect.X) + (Norm.y*Lightvect.Y) + (Norm.z*Lightvect.Z);
          if (dot > 1) or (dot < 0) then dot := 0;
          C2 := Round(dot * Num_of_shades);

          PointNormal(faces[polynr].P3,norm);
          dot := (norm.x*Lightvect.X) + (Norm.y*Lightvect.Y) + (Norm.z*Lightvect.Z);
          if (dot > 1) or (dot < 0) then dot := 0;
          C3 := Round(dot * Num_of_shades);

          PointNormal(faces[polynr].P4,norm);
          dot := (norm.x*Lightvect.X) + (Norm.y*Lightvect.Y) + (Norm.z*Lightvect.Z);
          if (dot > 1) or (dot < 0) then dot := 0;
          C4 := Round(dot * Num_of_shades);


          GouraudPolygon(X1,Y1,X2,Y2,X3,Y3,X4,Y4,c1,c2,c3,c4,where);
         end;
     {*******************************************************}
     {*******************************************************}
     {*******************************************************}
   end;
end;


PROCEDURE EnvironmentMap(source,dest : word);
var
 taeller : integer;
 X1,Y1,X2,Y2,X3,Y3,X4,Y4 : integer;
 U1,V1,U2,V2,U3,V3,U4,V4 : integer;
 polynr : integer;
 normal : integer;
 norm : PointT;

begin
 for taeller := 1 to Num_of_faces do
   begin
     polynr := orderTable[taeller];
     X1 := translated[faces[polynr].P1].X;
     Y1 := translated[faces[polynr].P1].Y;
     X2 := translated[faces[polynr].P2].X;
     Y2 := translated[faces[polynr].P2].Y;
     X3 := translated[faces[polynr].P3].X;
     Y3 := translated[faces[polynr].P3].Y;
     X4 := translated[faces[polynr].P4].X;
     Y4 := translated[faces[polynr].P4].Y;


     {*******************************************************}
     {******* HIDDEN FACE REMOVAL - YES, THAT EASY ;) *******}
     {*******************************************************}
     {Z-Comp of normal to 2d-polygon}
     normal := (Y1-Y3)*(X2-X1) - (X1-X3)*(Y2-Y1);
       if (normal < 0) then {pointing towards us}
         begin
           {************************************************************}
           {**           ENVIRONMENT MAPPING / FAKE PHONG             **}
           {************************************************************}

          FixedPointNormal(faces[polynr].P1,norm);
          u1 := (norm.X div 2) + 128;
          v1 := (norm.Y div 2) + 128;

          FixedPointNormal(faces[polynr].P2,norm);
          u2 := (norm.X div 2) + 128;
          v2 := (norm.Y div 2) + 128;

          FixedPointNormal(faces[polynr].P3,norm);
          u3 := (norm.X div 2) + 128;
          v3 := (norm.Y div 2) + 128;

          FixedPointNormal(faces[polynr].P4,norm);
          u4 := (norm.X div 2) + 128;
          v4 := (norm.Y div 2) + 128;

          TexturemapPolygon(X1,Y1,X2,Y2,X3,Y3,X4,Y4,
                            u1,v1,u2,v2,u3,v3,u4,v4,source,dest);
         end;
     {*******************************************************}
     {*******************************************************}
     {*******************************************************}
   end;
end;


Procedure SetLightSource(Xbeg,Ybeg,Zbeg,Xend,Yend,Zend : integer);
var
 lenght : real;
 Ax, Ay, Az : integer;
begin
  Ax := Xend - Xbeg;
  Ay := Yend - Ybeg;
  Az := Zend - Zbeg;   {vector from lightsource to lightdest}
  lenght := sqrt(Ax*Ax + Ay*Ay + Az*Az);
  lightvect.X := Ax/lenght;
  lightvect.Y := Ay/lenght;
  lightvect.Z := Az/lenght;
end;



Procedure TexturemapCube(source,outp : word);
{This one can be used for all kinds of fills : solid, textures, glenz...}
var
 taeller : integer;
 X1,Y1,X2,Y2,X3,Y3,X4,Y4 : integer;
 color : byte;
 polynr : integer;
 normal : integer;
begin
 for taeller := 1 to Num_of_faces do
   begin
     polynr := orderTable[taeller];
     X1 := translated[faces[polynr].P1].X;
     Y1 := translated[faces[polynr].P1].Y;
     X2 := translated[faces[polynr].P2].X;
     Y2 := translated[faces[polynr].P2].Y;
     X3 := translated[faces[polynr].P3].X;
     Y3 := translated[faces[polynr].P3].Y;
     X4 := translated[faces[polynr].P4].X;
     Y4 := translated[faces[polynr].P4].Y;
     color := faces[polynr].color;

     {*******************************************************}
     {******* HIDDEN FACE REMOVAL - YES, THAT EASY ;) *******}
     {*******************************************************}
     {Z-Comp of normal}
     normal := (Y1-Y3)*(X2-X1) - (X1-X3)*(Y2-Y1);
       if (normal < 0) then
         TextureMapPolygon(X1,Y1,X2,Y2,X3,Y3,X4,Y4,
                  0,0,255,0,255,255,0,255,source,outp);

     {*******************************************************}
     {*******************************************************}
     {*******************************************************}

   end;
end;






BEGIN



Clrscr;
Writeln('      ****************************************************************');
Writeln('      *                                                              *');
Writeln('      *                 3D OBJECT ENGINE - THE FILLS                 *');
Writeln('      *                        by : Telemachos                       *');
Writeln('      *                                                              *');
Writeln('      ****************************************************************');
Writeln;
Writeln('      Hiya! ');
Writeln('      Welcome to the Peroxide Programming Tips #4');
Writeln('      This one is on 3D objects - showing you how to shade those nice');
Writeln('      3d objects you have been making since the last tut :)');
Writeln('      This small demo contains five small parts. ');
Writeln('                                                                      ');
Writeln('         1) Bad Z-shading                      ');
Writeln('         2) Nice Flat shading according to lightsource');
Writeln('         3) Gouraud shaded cube according to lightsource..');
Writeln('         4) Texturemapped Cube - I will just use the entire phong map as texture');
Writeln('         5) Environmentmapping / FakePhong ');
Writeln;
Writeln('         Hit any key to switch between them....');
Writeln;
Writeln('      Calculating Phong map.. this may take a while...');

SetUpSegment(TexSegment,Texture);
CalcFakePhongMap(texture);

Writeln('      Done... hit any key to start');

readkey;

 asm
   mov ax,13h
   int 10h
 end;

Calc_cos_sin;
Init_Object;

Clear(0,VGA);
SetUpVirtual(scr2,vaddr);

Xrot := 0;
Yrot := 0;
Zrot := 0;

SetlightSource(0,0,-100,0,0,0); {peger nu lige ind i skaermen}

GreyScale;

repeat
 Rotateobj(Xrot,Yrot,Zrot);
 RotateNormals(Xrot,Yrot,Zrot);

 Xrot := (Xrot + 1) mod 360;
 Yrot := (Yrot + 3) mod 360;
 Zrot := (Zrot + 1) mod 360;
 Clear(0,Vaddr);


 Project_Points;
 Sort_faces;
 Clear(0,Vaddr);


 BadFlatShade(vaddr,-50,20,20);

 waitretrace;
 FlipScreen(vaddr,VGA);

until keypressed;
readkey;

repeat
 Rotateobj(Xrot,Yrot,Zrot);
 RotateNormals(Xrot,Yrot,Zrot);

 Xrot := (Xrot + 1) mod 360;
 Yrot := (Yrot + 3) mod 360;
 Zrot := (Zrot + 1) mod 360;
 Clear(0,Vaddr);


 Project_Points;
 Sort_faces;
 Clear(0,Vaddr);


 NiceFlatShade(vaddr,30);

 waitretrace;
 FlipScreen(vaddr,VGA);

until keypressed;
readkey;

PurplePal;

repeat
 Rotateobj(Xrot,Yrot,Zrot);
 RotateNormals(Xrot,Yrot,Zrot);

 Xrot := (Xrot + 1) mod 360;
 Yrot := (Yrot + 3) mod 360;
 Zrot := (Zrot + 1) mod 360;
 Clear(0,Vaddr);


 Project_Points;
 Sort_faces;
 Clear(0,Vaddr);


 GouraudShade(vaddr,63);

 waitretrace;
 FlipScreen(vaddr,VGA);

until keypressed;
readkey;


FakePhongPal;

repeat
 Rotateobj(Xrot,Yrot,Zrot);
 RotateNormals(Xrot,Yrot,Zrot);

 Xrot := (Xrot + 1) mod 360;
 Yrot := (Yrot + 3) mod 360;
 Zrot := (Zrot + 1) mod 360;
 Clear(0,Vaddr);


 Project_Points;
 Sort_faces;
 Clear(0,Vaddr);

 TextureMapCube(texture,vaddr);

 waitretrace;
 FlipScreen(vaddr,VGA);

until keypressed;
readkey;


repeat
 Rotateobj(Xrot,Yrot,Zrot);
 RotateNormals(Xrot,Yrot,Zrot);

 Xrot := (Xrot + 1) mod 360;
 Yrot := (Yrot + 3) mod 360;
 Zrot := (Zrot + 1) mod 360;
 Clear(0,Vaddr);


 Project_Points;
 Sort_faces;
 Clear(0,Vaddr);

 Environmentmap(texture,vaddr);

 waitretrace;
 FlipScreen(vaddr,VGA);

until keypressed;
readkey;



ShutDown(scr2);

asm
 mov ax,03h
 int 10h
end;

END.